SuperHack/SuperHack CD.bin/CODING/PASCAL/FPKPAS65.ZIP/SRCRTLDO.ZIP/SOURCE/RTL/DOS/DOS.PP

Text File | 1996-07-23 | 18.0 KB | 736 lines

{****************************************************************************

                          FPKPascal Runtime-Library
                          Copyright (c) 1993,95 by
                              Florian Klämpfl

 ****************************************************************************}

{
  History:
  2.7.1994: Version 0.2
            Datenstrukturen sind deklariert sowie
            50 % der Unterprogramme sind implementiert
  12.8.1994: EXEC implementiert
  14.8.1994: FINDFIRST und FINDNEXT implementiert
  24.8.1994: Version 0.3
  28.2.1995: Version 0.31
             verschiedene Prozeduraufrufe durch Einsatz von const optimiert
   3.7.1996: bug in fsplit removed (dir and ext were not intializised)
   7.7.1996: packtime and unpacktime implemented
}

unit dos;

{$E-}

  interface

    uses
       strings;

    const
       { bit masks for CPU flags}
       fcarry = $0001;
       fparity = $0004;
       fauxiliary = $0010;
       fzero = $0040;
       fsign = $0080;
       foverflow  = $0800;

       { Bitmasken fuer Dateiattribute }
       readonly = $01;
       hidden = $02;
       sysfile = $04;
       volumeid = $08;
       directory = $10;
       archive = $20;
       anyfile = $3F;
       fmclosed = $D7B0;
       fminput = $D7B1;
       fmoutput = $D7B2;
       fminout = $D7B3;

    type
       { verschiedene Stringtypen }
       comstr = string[127];        { Kommandozeilenstring }
       pathstr = string[79];        { String fuer einen Pfadnamen }
       dirstr = string[67];         { String fuer kompletten Pfad }
       namestr = string[8];         { Dateinamenstring }
       extstr = string[4];          { String fuer Dateinamensuffix }

       { Suchrecords, die von findfirst und findnext benutzt werden }
{$PACKRECORDS 1}
       searchrec = record
          fill : array[1..21] of byte;
          attr : byte;
          time : longint;
          size : longint;
          reserved : word; { verlangt (DJ GNU-C) }
             { bis ich das herausgefunden hatte... }
          name : string[12];
             { könnte auch als string[15] deklariert werden (DJ GNU-C) }
       end;
{$PACKRECORDS 2}
       { Dateirecord für typisierte und untypsierte Dateien }

       filerec = record
          handle : word;
          mode : word;
          recsize : word;
          _private : array[1..26] of byte;
          userdata: array[1..16] of byte;
          name: array[0..79] of char;
       end;

       { Dateirecord fuer Textdateien }

       textbuf = array[0..127] of char;

       textrec = record
          handle : word;
          mode : word;
          bufSize : word;
          _private : word;
          bufpos : word;
          bufend : word;
          bufptr : ^textbuf;
          openfunc : pointer;
          inoutfunc : pointer;
          flushfunc : pointer;
          closefunc : pointer;
          userdata : array[1..16] of byte;
          name : array[0..79] of char;
          buffer : textbuf;
       end;

       { Record welcher von Intr und msdos verwendet werden }

       registers = record
         case i : integer of
            0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
            1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
            2 : (eax,  ebx,  ecx,  edx,  ebp,  esi,  edi : longint);
       end;

       { Record fuer Zeit und Datum }

       datetime = record
          year,month,day,hour,min,sec : word;
       end;

    var
       { Fehlervariable }
       doserror : integer;

    procedure getdate(var year,month,day,dayofweek : word);
    procedure gettime(var hour,minute,second,sec100 : word);
    function dosversion : word;
    procedure setdate(year,month,day : word);
    procedure settime(hour,minute,second,sec100 : word);
    procedure getcbreak(var breakvalue : boolean);
    procedure setcbreak(breakvalue : boolean);
    procedure getverify(var verify : boolean);
    procedure setverify(verify : boolean);
    function diskfree(drive : byte) : longint;
    function disksize(drive : byte) : longint;
    procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
    procedure findnext(var f : searchRec);

    { Dummy }
    procedure swapvectors;

{   Nicht unterstützt:

    procedure msdos(var regs : registers);
    procedure getintvec(intno : byte;var vector : pointer);
    procedure setintvec(intno : byte;vector : pointer);
    procedure keep(exitcode : word);
}
    procedure intr(intno : byte;var regs : registers);

{ Noch zu implementieren:
    procedure getfattr(var f;var attr : word);
    procedure setfattr(var f;attr : word);
    procedure getftime(var f;var time : longint);
    procedure setftime(var f;time : longint);
    function fsearch(path : pathstr;dirlist : string) : pathstr;

}
    procedure packtime (var d: datetime; var time: longint);
    procedure unpacktime (time: longint; var d: datetime);
    function fexpand(const path : pathstr) : pathstr;
    procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;
      var ext : extstr);
    procedure exec(const path : pathstr;const comline : comstr);
    function dosexitcode : word;
    function envcount : integer;
    function envstr(index : integer) : string;
    function getenv(const envvar : string): string;

  implementation

    procedure intr(intno : byte;var regs : registers);

      begin
         asm
            .data
    int86:
            .byte        0xcd
    int86_vec:
            .byte        0x03
            jmp        int86_retjmp

            .text
            movl        8(%ebp),%eax
            movb        %al,int86_vec

            movl        10(%ebp),%eax
            // do not use first int
            addl        $2,%eax

            movl        4(%eax),%ebx
            movl        8(%eax),%ecx
            movl        12(%eax),%edx
            movl        16(%eax),%ebp
            movl        20(%eax),%esi
            movl        24(%eax),%edi
            movl        (%eax),%eax

            jmp        int86
    int86_retjmp:
            pushf
            pushl    %ebp
            pushl       %eax
            movl        %esp,%ebp
            // calc EBP new
            addl        $12,%ebp
            movl        10(%ebp),%eax
            // do not use first int
            addl        $2,%eax

            popl        (%eax)
            movl        %ebx,4(%eax)
            movl        %ecx,8(%eax)
            movl        %edx,12(%eax)
            // restore EBP
            popl    %edx
            movl    %edx,16(%eax)
            movl        %esi,20(%eax)
            movl        %edi,24(%eax)
            // ignore ES and DS
            popl        %ebx        /* flags */
            movl        %ebx,32(%eax)
            // FS and GS too
         end;
      end;

    var
       lastdosexitcode : word;

    procedure exec(const path : pathstr;const comline : comstr);

      procedure do_system(p : pchar);

        begin
           asm
              movl 12(%ebp),%ebx
              movw $0xff07,%ax
              int $0x21
              movw %ax,_LASTDOSEXITCODE
           end;
        end;

      var
         execute : string;
         b : array[0..255] of char;

      begin
         execute:=path+' '+comline;
         move(execute[1],b,length(execute));
         b[length(execute)]:=#0;
         do_system(b);
      end;

    function dosexitcode : word;

      begin
         dosexitcode:=lastdosexitcode;
      end;

    function dosversion : word;

      begin
         asm
            movb $0x30,%ah
            pushl %ebp
            int $0x21
            popl %ebp
            leave
            ret
         end;
      end;

    procedure getdate(var year,month,day,dayofweek : word);

      begin
         asm
            movb $0x2a,%ah
            pushl %ebp
            int $0x21
            popl %ebp
            xorb %ah,%ah
            movl 20(%ebp),%edi
            stosw
            movl 16(%ebp),%edi
            movb %dl,%al
            stosw
            movl 12(%ebp),%edi
            movb %dh,%al
            stosw
            movl 8(%ebp),%edi
            movw %cx,%ax
            stosw
         end;
      end;

    procedure setdate(year,month,day : word);

      begin
         asm
            movw 8(%ebp),%cx
            movb 10(%ebp),%dh
            movb 12(%ebp),%dl
            movb $0x2b,%ah
            pushl %ebp
            int $0x21
            popl %ebp
            xorb %ah,%ah
            movw %ax,U_DOS_DOSERROR
         end;
      end;

    procedure gettime(var hour,minute,second,sec100 : word);

      begin
         asm
            movb $0x2c,%ah
            pushl %ebp
            int $0x21
            popl %ebp
            xorb %ah,%ah
            movl 20(%ebp),%edi
            movb %dl,%al
            stosw
            movl 16(%ebp),%edi
            movb %dh,%al
            stosw
            movl 12(%ebp),%edi
            movb %cl,%al
            stosw
            movl 8(%ebp),%edi
            movb %ch,%al
            stosw
         end;
      end;

    procedure settime(hour,minute,second,sec100 : word);

      begin
         asm
            movb 8(%ebp),%ch
            movb 10(%ebp),%cl
            movb 12(%ebp),%dh
            movb 14(%ebp),%dl
            movb $0x2d,%ah
            pushl %ebp
            int $0x21
            popl %ebp
            xorb %ah,%ah
            movw %ax,U_DOS_DOSERROR
         end;
      end;

    procedure getcbreak(var breakvalue : boolean);

      begin
         asm
            movw $0x3300,%ax
            pushl %ebp
            int $0x21
            popl %ebp
            movl 8(%ebp),%eax
            movb %dl,(%eax)
         end;
      end;

    procedure setcbreak(breakvalue : boolean);

      begin
         asm
            movb 8(%ebp),%dl
            movl $0x3301,%ax
            pushl %ebp
            int $0x21
            popl %ebp
         end;
      end;

    procedure getverify(var verify : boolean);

      begin
         asm
            movb $0x54,%ah
            pushl %ebp
            int $0x21
            popl %ebp
            movl 8(%ebp),%edi
            stosb
         end;
      end;

    procedure setverify(verify : boolean);

      begin
         asm
            movb 8(%ebp),%al
            movl $0x2e,%ah
            pushl %ebp
            int $0x21
            popl %ebp
         end;
      end;

    function diskfree(drive : byte) : longint;

      begin
         asm
            movb 8(%ebp),%dl
            movb $0x36,%ah
            pushl %ebp
            int $0x21
            popl %ebp
            cmpw $-1,%ax
            je LDISKFREE1
            mulw %cx
            mulw %bx
            shll $16,%edx
            movw %ax,%dx
            movl %edx,%eax
            leave
            ret
         LDISKFREE1:
            movl $-1,%eax
            leave
            ret
         end;
      end;

    function disksize(drive : byte) : longint;

      begin
         asm
            movb 8(%ebp),%dl
            movb $0x36,%ah
            pushl %ebp
            int $0x21
            popl %ebp
            movw %dx,%bx
            cmpw $-1,%ax
            je LDISKSIZE1
            mulw %cx
            mulw %bx
            shll $16,%edx
            movw %ax,%dx
            movl %edx,%eax
            leave
            ret
         LDISKSIZE1:
            movl $-1,%eax
            leave
            ret
         end;
      end;

    procedure searchrec2dossearchrec(var f : searchrec);

      var
         l,i : longint;

      begin
         l:=length(f.name);
         for i:=1 to 12 do
           f.name[i-1]:=f.name[i];
         f.name[l]:=#0;
      end;

    procedure dossearchrec2searchrec(var f : searchrec);

      var
         l,i : longint;

      begin
         for i:=0 to 12 do
           if f.name[i]=#0 then
             begin
                l:=i;
                break;
             end;
         for i:=11 downto 0 do
           f.name[i+1]:=f.name[i];
         f.name[0]:=chr(l);
      end;

    procedure findfirst(const path : pathstr;attr : word;var f : searchRec);

      procedure _findfirst(path : pchar;attr : word;var f : searchrec);

        begin
           asm
              movl 18(%ebp),%edx
              movb $0x1a,%ah
              int $0x21
              movl 12(%esp),%edx
              movzwl 16(%esp),%ecx
              movb $0x4e,%ah
              int $0x21
              jnc LFF
              movw %ax,U_DOS_DOSERROR
           LFF:
           end;
        end;

      var
         path0 : array[0..80] of char;

      begin
         { kein Fehler }
         doserror:=0;
         strpcopy(path0,path);
         _findfirst(path0,attr,f);
         dossearchrec2searchrec(f);
      end;

    procedure findnext(var f : searchRec);

      procedure _findnext(var f : searchrec);

        begin
           asm
              movl 12(%ebp),%edx
              movb $0x1a,%ah
              int $0x21
              movb $0x4f,%ah
              int $0x21
              jnc LFN
              movw %ax,U_DOS_DOSERROR
           LFN:
           end;
        end;

      begin
         { kein Fehler }
         doserror:=0;
         searchrec2dossearchrec(f);
         _findnext(f);
         dossearchrec2searchrec(f);
      end;

    procedure swapvectors;

      begin
         { tut nichts, DOS-Extender übernimmt das Nötige }
         { normalerweise selber                          }
         { nur aus Kompatibilitätsgründen implementiert  }
      end;

    type
       ppchar = ^pchar;

    function envs : ppchar;

      begin
         asm
            movl _environ,%eax
            leave
            ret
         end ['EAX'];
      end;

    function envcount : integer;

      var
         hp : ppchar;

      begin
         hp:=envs;
         envcount:=0;
         while assigned(hp^) do
           begin
              { doppeltgemopelt, aber übersichtlicher }
              inc(envcount);
              hp:=hp+4;
           end;
      end;

    function envstr(index : integer) : string;

      var
         i : longint;
         hp : ppchar;

      begin
         if (index<=0) or (index>envcount) then
           begin
              envstr:='';
              exit;
           end;
         hp:=envs+4*(index-1);
         envstr:=strpas(hp^);
      end;

    function getenv(const envvar : string) : string;

      var
         hs,_envvar : string;
         eqpos,i : longint;

      begin
         _envvar:=upcase(envvar);
         getenv:='';
         for i:=1 to envcount do
           begin
              hs:=envstr(i);
              eqpos:=pos('=',hs);
              if copy(hs,1,eqpos-1)=_envvar then
                begin
                   getenv:=copy(hs,eqpos+1,length(hs)-eqpos);
                   exit;
                end;
           end;
      end;

    procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;
      var ext : extstr);

      var
         s1 : string;
         p1 : byte;

      begin
         { try to find out a extension }
         p1:=pos('.',path);
         if p1>0 then
           begin
              ext:=copy(path,p1,4);
              delete(path,p1,length(path)-p1+1);
           end
         else
           ext:='';
         { get drive name }
         p1:=pos(':',path);
         if p1>0 then
           begin
              dir:=path[1]+':';
              delete(path,1,p1);
           end
         else
           dir:='';
         { split the path and the name, there are no more path informtions }
         { if path contains no backslashes                                 }
         while true do
           begin
              p1:=pos('\',path);
              if p1=0 then
                break;
              dir:=dir+copy(path,1,p1);
              delete(path,1,p1);
           end;
         name:=path;
      end;

    function fexpand(const path : pathstr) : pathstr;

      var
         retpath : pathstr;

      function get_current_drive : char;

        begin
           asm
              movb 0x19,%ah
              int $0x21
              addb $65,%al
              leave
              ret
           end;
        end;

      function get_path(drive : byte) : string;

        begin
           asm
           end;
        end;

      var
         i : longint;

      begin
         i:=1;
         { Laufwerk feststellen }
         if (path<>'') and (path[2]=':') then
            begin
               retpath:=upcase(path[1]);
               i:=3;
            end
         else
            retpath:=get_current_drive;
         retpath:=retpath+':';
         if path[i]<>'\' then
           begin
              retpath:=retpath+'\';
              inc(i);
              get_path(ord(retpath[1])-64);
           end;
         fexpand:=retpath;
      end;

     procedure packtime (var d: datetime; var time: longint);

       var
          zs: longint;

       begin
          time:= -1980;
          time:= time + d.year and 127;
          time:= time shl 4;
          time := time + d.month;
          time:= time shl 5;
          time := time + d.day;
          time:= time shl 16;
          zs := d.hour;
          zs:= zs shl 6;
          zs := zs + d.min;
          zs:= zs shl 5;
          zs := zs + d.sec div 2;
          time := time + zs and 65535;
       end;

     procedure unpacktime (time: longint; var d: datetime);

       begin
          d.sec:= (time and 31) * 2;
          time:= time shr 5;
          d.min:= time and 63;
          time:= time shr 6;
          d.hour:= time and 31;
          time:= time shr 5;
          d.day:= time and 31;
          time:= time shr 5;
          d.month:= time and 15;
          time:= time shr 4;
          d.year:= time + 1980;
       end;
end.